{-# OPTIONS_GHC -fglasgow-exts #-}
module Data.Tuple.Projection.Internal where
import Language.Haskell.TH
import Data.List

projectionsUpToDim :: Int -> Q [Dec]
projectionsUpToDim = return . map declare . reductionsUpToDim
    where declare (r,p) = InstanceD
            []
            (mkParametricT [ConT (mkName "Projection"), mkTupT r, mkTupT p])
            [FunD (mkName "project") [ Clause
                [mkWildTupP p r]
                (NormalB $ mkTupE p)
                [] ] ]

expandProjectionsUpToDim :: Int -> Q [Dec]
expandProjectionsUpToDim = return . map declare . expandedReductionsUpToDim
    where declare (r,p) = InstanceD
            (map (\c-> mkParametricT [ConT (mkName "Projection")
                                     ,mkTupT r
                                     ,mkTupT [c] ])
                  p)
            (mkParametricT [ConT (mkName "Projection"), mkTupT r, mkTupT p])
            [FunD (mkName "project") [ Clause
                [VarP (mkName "r")]
                (NormalB $ TupE  (map (\_-> AppE (VarE $ mkName "project")
                                                 (VarE $ mkName "r") )
                                      p))
                [] ] ]

reductionsUpToDim :: Int -> [([Char],[Char])]
reductionsUpToDim = foldl1' (++) . map (\x-> uncurry (map . (,))
    (x, combinations 1 x)) .
    tail . inits . mkSeq 'a'

expandedReductionsUpToDim :: Int -> [([Char],[Char])]
expandedReductionsUpToDim = foldl1' (++) . map (uncurry (map . (,)) .
    (\x->(x,map (mkSeq (succ $ last x)) [2..length x]))) .
    tail . tail . inits . mkSeq 'a'

combinations :: (Integral t) => t -> [a] -> [[a]]
combinations 0 _  = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs
                           , ys <- combinations (pred n) xs' ]

mkSeq :: (Num a, Ord a, Enum a, Enum b) => b -> a -> [b]
mkSeq z n | n < 1     = []
          | otherwise = z : mkSeq (succ z) (pred n)

mkParametricT :: [Type] -> Type
mkParametricT = foldl1' AppT

mkFunT :: [Type] -> Type
mkFunT = foldl1' $ \t1 t2-> AppT (AppT ArrowT t1) t2

mkTupT :: [Char] -> Type
mkTupT (c:[]) = VarT (mkName [c])
mkTupT cs     = foldl' AppT (TupleT (length cs)) (map (VarT . mkName . (:[])) cs)

mkTupP :: [Maybe Char] -> Pat
mkTupP (c:[]) = _f c
mkTupP cs     = TupP (map _f cs)
_f Nothing  = WildP
_f (Just c) = VarP (mkName [c])

-- needed vars -> all vars -> pattern
mkWildTupP :: [Char] -> [Char] -> Pat
mkWildTupP cs = mkTupP . map (\c -> if any (==c) cs then Just c else Nothing)

mkTupE :: [Char] -> Exp
mkTupE (c:[]) = VarE (mkName [c])
mkTupE cs     = TupE  (map ( VarE . mkName . (:[]) ) cs)

